home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / PRG / MacPerl 506 appl folder.sit / MacPerl 506 appl folder / Mac_Perl_506r1m_appl / lib / macchat.pl < prev    next >
Text File  |  1996-01-14  |  7KB  |  293 lines
  1. ## macchat.pl: chat with a server over any protocol
  2. ## Matthias Neeracher
  3.  
  4. ## Derived from chat2pl
  5. ## V2.01.alpha.7 91/06/16
  6. ## Randal L. Schwartz
  7.  
  8. package macchat;
  9.  
  10. require 'GUSI.ph';
  11.  
  12. # *S = symbol for current I/O, gets assigned *chatsymbol....
  13. $next = "chatsymbol000000"; # next one
  14. $nextpat = "^chatsymbol"; # patterns that match next++, ++, ++, ++
  15.  
  16.  
  17. ## $handle = &chat'open_port($family, $addr [, $ouraddr]);
  18. ## opens a named or numbered server. 
  19. ## $addr may be created with one of the pack_sockaddrﾉ routines in GUSI.pl
  20.  
  21. sub open_port { ## public
  22.     local($family, $addr, $ouraddr) = @_;
  23.  
  24.     *S = ++$next;
  25.     unless (socket(S, $family, &GUSI'SOCK_STREAM, 0)) {
  26.         ($!) = ($!, close(S)); # close S while saving $!
  27.         return undef;
  28.     }
  29.     if (defined($ouraddr)) {
  30.         unless (bind(S, $ouraddr)) {
  31.             ($!) = ($!, close(S)); # close S while saving $!
  32.             return undef;
  33.         }
  34.     }
  35.     unless (connect(S, $addr)) {
  36.         ($!) = ($!, close(S)); # close S while saving $!
  37.         return undef;
  38.     }
  39.     select((select(S), $| = 1)[0]);
  40.     $next; # return symbol for switcharound
  41. }
  42.  
  43. ## ($addr, $handle) = &chat'open_listen($family, [$ouraddr]);
  44. ## opens a TCP port on the current machine, ready to be listened to
  45. ## if $port_number is absent or zero, pick a default port number
  46. ## process must be uid 0 to listen to a low port number
  47.  
  48. sub open_listen { ## public
  49.  
  50.     *S = ++$next;
  51.     local($family, $ouraddr) = @_;
  52.     local(*NS) = "__" . time;
  53.     unless (socket(NS, $family, &GUSI'SOCK_STREAM, 0)) {
  54.         ($!) = ($!, close(NS));
  55.         return undef;
  56.     }
  57.     if (defined $ouraddr) {
  58.         unless (bind(NS, $ouraddr)) {
  59.             ($!) = ($!, close(NS));
  60.             return undef;
  61.         }
  62.     }
  63.     unless (listen(NS, 1)) {
  64.         ($!) = ($!, close(NS));
  65.         return undef;
  66.     }
  67.     select((select(NS), $| = 1)[0]);
  68.     $S{"needs_accept"} = *NS; # so expect will open it
  69.     (getsockname(NS), $next); # returning this
  70. }
  71.  
  72. # $S is the read-ahead buffer
  73.  
  74. ## $return = &chat'expect([$handle,] $timeout_time,
  75. ##     $pat1, $body1, $pat2, $body2, ... )
  76. ## $handle is from previous &chat'open_*().
  77. ## $timeout_time is the time (either relative to the current time, or
  78. ## absolute, ala time(2)) at which a timeout event occurs.
  79. ## $pat1, $pat2, and so on are regexs which are matched against the input
  80. ## stream.  If a match is found, the entire matched string is consumed,
  81. ## and the corresponding body eval string is evaled.
  82. ##
  83. ## Each pat is a regular-expression (probably enclosed in single-quotes
  84. ## in the invocation).  ^ and $ will work, respecting the current value of $*.
  85. ## If pat is 'TIMEOUT', the body is executed if the timeout is exceeded.
  86. ## If pat is 'EOF', the body is executed if the process exits before
  87. ## the other patterns are seen.
  88. ##
  89. ## Pats are scanned in the order given, so later pats can contain
  90. ## general defaults that won't be examined unless the earlier pats
  91. ## have failed.
  92. ##
  93. ## The result of eval'ing body is returned as the result of
  94. ## the invocation.  Recursive invocations are not thought
  95. ## through, and may work only accidentally. :-)
  96. ##
  97. ## undef is returned if either a timeout or an eof occurs and no
  98. ## corresponding body has been defined.
  99. ## I/O errors of any sort are treated as eof.
  100.  
  101. $nextsubname = "expectloop000000"; # used for subroutines
  102.  
  103. sub expect { ## public
  104.     if ($_[0] =~ /$nextpat/) {
  105.         *S = shift;
  106.     }
  107.     local($endtime) = shift;
  108.  
  109.     local($timeout,$eof) = (1,1);
  110.     local($caller) = caller;
  111.     local($rmask, $nfound, $timeleft, $thisbuf);
  112.     local($cases, $pattern, $action, $subname);
  113.     $endtime += time if $endtime < 600_000_000;
  114.  
  115.     if (defined $S{"needs_accept"}) { # is it a listen socket?
  116.         local(*NS) = $S{"needs_accept"};
  117.         delete $S{"needs_accept"};
  118.         $S{"needs_close"} = *NS;
  119.         unless(accept(S,NS)) {
  120.             ($!) = ($!, close(S), close(NS));
  121.             return undef;
  122.         }
  123.         select((select(S), $| = 1)[0]);
  124.     }
  125.  
  126.     # now see whether we need to create a new sub:
  127.  
  128.     unless ($subname = $expect_subname{$caller,@_}) {
  129.         # nope.  make a new one:
  130.         $expect_subname{$caller,@_} = $subname = $nextsubname++;
  131.  
  132.         $cases .= <<"EDQ"; # header is funny to make everything elsif's
  133. sub $subname {
  134.     LOOP: {
  135.         if (0) { ; }
  136. EDQ
  137.         while (@_) {
  138.             ($pattern,$action) = splice(@_,0,2);
  139.             if ($pattern =~ /^eof$/i) {
  140.                 $cases .= <<"EDQ";
  141.         elsif (¥$eof) {
  142.              package $caller;
  143.             $action;
  144.         }
  145. EDQ
  146.                 $eof = 0;
  147.             } elsif ($pattern =~ /^timeout$/i) {
  148.             $cases .= <<"EDQ";
  149.         elsif (¥$timeout) {
  150.              package $caller;
  151.             $action;
  152.         }
  153. EDQ
  154.                 $timeout = 0;
  155.             } else {
  156.                 $pattern =~ s#/#¥¥/#g;
  157.             $cases .= <<"EDQ";
  158.         elsif (¥$S =~ /$pattern/) {
  159.             ¥$S = ¥$';
  160.              package $caller;
  161.             $action;
  162.         }
  163. EDQ
  164.             }
  165.         }
  166.         $cases .= <<"EDQ" if $eof;
  167.         elsif (¥$eof) {
  168.             undef;
  169.         }
  170. EDQ
  171.         $cases .= <<"EDQ" if $timeout;
  172.         elsif (¥$timeout) {
  173.             undef;
  174.         }
  175. EDQ
  176.         $cases .= <<'ESQ';
  177.         else {
  178.             $rmask = "";
  179.             vec($rmask,fileno(S),1) = 1;
  180.             ($nfound, $rmask) =
  181.                  select($rmask, undef, undef, $endtime - time);
  182.             if ($nfound) {
  183.                 $nread = sysread(S, $thisbuf, 1024);
  184.                 if ($nread > 0) {
  185.                     $S .= $thisbuf;
  186.                 } else {
  187.                     $eof++, redo LOOP; # any error is also eof
  188.                 }
  189.             } else {
  190.                 $timeout++, redo LOOP; # timeout
  191.             }
  192.             redo LOOP;
  193.         }
  194.     }
  195. }
  196. ESQ
  197.         eval $cases; die "$cases:¥n$@" if $@;
  198.     }
  199.     $eof = $timeout = 0;
  200.     do $subname();
  201. }
  202.  
  203. ## &chat'print([$handle,] @data)
  204. ## $handle is from previous &chat'open().
  205. ## like print $handle @data
  206.  
  207. sub print { ## public
  208.     if ($_[0] =~ /$nextpat/) {
  209.         *S = shift;
  210.     }
  211.  
  212.     if (defined $S{"needs_accept"}) { # is it a listen socket?
  213.         local(*NS) = $S{"needs_accept"};
  214.         delete $S{"needs_accept"};
  215.         $S{"needs_close"} = *NS;
  216.         unless(accept(S,NS)) {
  217.             ($!) = ($!, close(S), close(NS));
  218.             return undef;
  219.         }
  220.         select((select(S), $| = 1)[0]);
  221.     }
  222.     
  223.     print S @_;
  224. }
  225.  
  226. ## &chat'close([$handle,])
  227. ## $handle is from previous &chat'open().
  228. ## like close $handle
  229.  
  230. sub close { ## public
  231.     local($pid);
  232.     if ($_[0] =~ /$nextpat/) {
  233.         $pid = $PID{$_[0]};
  234.          *S = shift;
  235.     } else {
  236.         $pid = $PID{$next};
  237.     }
  238.     close(S);
  239.     if (defined $S{"needs_close"}) { # is it a listen socket?
  240.         local(*NS) = $S{"needs_close"};
  241.         delete $S{"needs_close"};
  242.         close(NS);
  243.     }
  244. }
  245.  
  246. ## @ready_handles = &chat'select($timeout, @handles)
  247. ## select()'s the handles with a timeout value of $timeout seconds.
  248. ## Returns an array of handles that are ready for I/O.
  249. ## Both user handles and chat handles are supported (but beware of
  250. ## stdio's buffering for user handles).
  251.  
  252. sub select { ## public
  253.     local($timeout) = shift;
  254.     local(@handles) = @_;
  255.     local(%handlename) = ();
  256.     local(%ready) = ();
  257.     local($caller) = caller;
  258.     local($rmask) = "";
  259.     for (@handles) {
  260.         if (/$nextpat/o) { # one of ours... see if ready
  261.             local(*SYM) = $_;
  262.                 if (defined $SYM{"needs_accept"}) { # is it a listen socket?
  263.                     local(*NS) = $SYM{"needs_accept"};
  264.                     delete $SYM{"needs_accept"};
  265.                     $SYM{"needs_close"} = *NS;
  266.                     unless(accept(SYM,NS)) {
  267.                         ($!) = ($!, close(SYM), close(NS));
  268.                         return undef;
  269.                     }
  270.                     select((select(SYM), $| = 1)[0]);
  271.                 }
  272.  
  273.             if (length($SYM)) {
  274.                 $timeout = 0; # we have a winner
  275.                 $ready{$_}++;
  276.             }
  277.             $handlename{fileno($_)} = $_;
  278.         } else {
  279.             $handlename{fileno(/'/ ? $_ : "$caller¥'$_")} = $_;
  280.         }
  281.     }
  282.     for (sort keys %handlename) {
  283.         vec($rmask, $_, 1) = 1;
  284.     }
  285.     select($rmask, undef, undef, $timeout);
  286.     for (sort keys %handlename) {
  287.         $ready{$handlename{$_}}++ if vec($rmask,$_,1);
  288.     }
  289.     sort keys %ready;
  290. }
  291.  
  292. 1;
  293.